(* The APost Interpreter *)

open Utils;;

open Environment;;

let rec do_cmd stack env c = match c with
(* Simple literals *)
    IntConst (i, l) -> push (Integer i) stack
  | StringConst (s, l) -> push (String s) stack
  | BoolConst (b, l) -> push (Boolean b) stack
  | ProcConst (proc, l1, l2) -> push (Procedure (proc, env)) stack
  | NoneConst l -> push Noneval stack
(* Arithmetic Operators *)
  | Add l -> let t1 = pop stack l in
        let t2 = pop stack l in
        (
        match (t1, t2) with
            (Integer l, Integer r) -> push (Integer (l+r)) stack
          | (String l, String r) -> push (String (l^r)) stack
          | _ -> raise_exception stack "Argument type mismatch, arithmetic operations only work on numbers." l
        )
  | Sub l -> let t1 = pop stack l in
        let t2 = pop stack l in
        (
        match (t1, t2) with
            (Integer l, Integer r) -> push (Integer (l-r)) stack
          | _ -> raise_exception stack "Argument type mismatch, arithmetic operations only work on numbers." l
        )
  | Mul l -> let t1 = pop stack l in
        let t2 = pop stack l in
        (
        match (t1, t2) with
            (Integer l, Integer r) -> push (Integer (l*r)) stack
          | _ -> raise_exception stack "Argument type mismatch, arithmetic operations only work on numbers." l
        )
  | Div l -> let t1 = pop stack l in
        let t2 = pop stack l in
        (   
        match (t1, t2) with
            (Integer l, Integer r) -> push (Integer (l / r)) stack
          | _ -> raise_exception stack "Argument type mismatch, arithmetic operations only work on numbers." l
        )
  | Mod l -> let t1 = pop stack l in
        let t2 = pop stack l in
        (   
        match (t1, t2) with
            (Integer l, Integer r) -> push (Integer (l mod r)) stack
          | _ -> raise_exception stack "Argument type mismatch, arithmetic operations only work on numbers." l
        )
  | Lt l -> 
        let rarg = pop stack l in
        let larg = pop stack l in
        (
        match (larg, rarg) with
            (Integer left, Integer right) -> 
                (
                if left < right then 
                    push (Boolean true) stack
                else
                    push (Boolean false) stack
                )
          | _ -> raise_exception stack "Comparisons are only implemented for numbers." l
        )
  | Gt l -> 
        let rarg = pop stack l in
        let larg = pop stack l in
        (
        match (larg, rarg) with
            (Integer left, Integer right) -> 
                (
                if left > right then 
                    push (Boolean true) stack
                else
                    push (Boolean false) stack
                )
          | _ -> raise_exception stack "Comparisons are only implemented for numbers." l
        )
  | Eq l -> 
        let rarg = pop stack l in
        let larg = pop stack l in
        (
        match (larg, rarg) with
            (Integer left, Integer right) -> 
                (
                if left = right then 
                    push (Boolean true) stack
                else
                    push (Boolean false) stack
                )
          | (String left, String right) ->
                (
                if (String.compare left right) = 0 then
                    push (Boolean true) stack
                else
                    push (Boolean false) stack        
                )
          | _ -> raise_exception stack "Comparisons are only implemented for numbers and strings." l
        )
  | Print l ->
        (
        match pop stack l with
            String s -> print_string s
          | _ -> raise_exception stack "Argument type mismatch, printing requires a String." l
        )
  | Printline l ->
        (
        match pop stack l with
            String s -> print_endline s
          | _ -> raise_exception stack "Argument type mismatch, printing requires a String." l
        )
  | Call l ->
        (
        
        match pop stack l with
            Procedure (cs, env') -> (
                let env'' = new_env env' in
                try 
                    List.iter (do_cmd stack env'') cs
                with APostReturn -> ()           (* Yes, this is deliberately a no-op *)
                  |  APostException ls -> raise (APostException (l :: ls))
                  |  Stack_overflow -> raise (APostException [l])
                )
          | _ -> raise_exception stack "Call commands require a Procedure on top of the stack." l
        )
  | Set_dict l ->
        let d = pop stack l in
        let key = pop stack l in
        let value = pop stack l in
        (
        match d with
            Dict d_env -> Hashtbl.add !d_env key value;
          | _ -> raise_exception stack "Argument type mismatch, Dictionary operations require a Dictionary on top of the stack." l
        )
  | Store l ->
        let key = pop stack l in
        let value = pop stack l in
        bind_env env key value
  | Get_dict l ->
        let d = pop stack l in
        let key = pop stack l in
        (
        match d with
            Dict d_env -> 
                (
                try
                    push (Hashtbl.find !d_env key) stack
                with Not_found -> 
                    raise_exception stack ("Key not found in dictionary: " ^ (string_of_varTypes d) ^".") l
                )
          | _ -> raise_exception stack "Argument type mismatch, Dictionary operations require a Dictionary on top of the stack." l
        )
  | Load l ->
        let key = pop stack l in
        (
        try
            push (get_env env key) stack
        with Not_found ->
            raise_exception stack "Variable not found in the Environment" l
        )
  | New_dict l -> 
        let d = Hashtbl.create 50 in
        (
        match pop stack l with
            Integer n -> let n1 = ref n in
                while !n1 > 0 do
                    let k = pop stack l in
                    let v = pop stack l in
                    Hashtbl.add d k v;
                    n1 := !n1 - 1;
                done
          | _ -> raise_exception stack "The number of K-V pairs in a new dictionary must be an integer." l
        );
        push (Dict (ref d)) stack
  | Has_dict l ->
        let d = pop stack l in
        let key = pop stack l in
        (
            match d with
            | Dict d_env -> push (Boolean (Hashtbl.mem !d_env key)) stack
            | _ -> raise_exception stack ("has_dict expects a dictionary on the stack, got " ^ (string_of_varTypes d) ^ " while looking for " ^ (string_of_varTypes key)) l
        )
  | Exception l -> ignore (raise (APostException [l]));  (* ignore so that the expression type-checks correctly *)
  | Push_env l -> push (Dict (get_hashtbl env)) stack
  | Loop l -> let cond = pop stack l in
        let bs = 
            (
            match pop stack l with
                Procedure (bs, env') -> bs
              | _ -> ignore (raise_exception stack "Loop commands require a Procedure for the body of the loop." l);
                    []              (* needed for the types to match, this is never executed *)
            ) in
        while exec_cond stack  cond l do
            List.iter (do_cmd stack env) bs
        done
  | Tostring l -> 
      push (String (string_of_varTypes (pop stack l))) stack
  | Branch l -> let cond = pop stack l in
        let fs = 
            (
            match pop stack l with
                Procedure (bs, env') -> bs
              | _ -> ignore (raise_exception stack "Branch commands require a Procedure for the body." l); 
                    []          (* needed for the types to match, this is never executed *)
            ) in
        let ts = 
            (
            match pop stack l with
                Procedure (bs, env') -> bs
              | _ -> ignore (raise_exception stack "Branch commands require a Procedure for the body." l); 
                    []          (* needed for the types to match, this is never executed *)
            ) in
        if exec_cond stack cond l then
            List.iter (do_cmd stack env) ts
        else
            List.iter (do_cmd stack env) fs
  | Return l -> ignore (raise APostReturn)
  | New_list l -> 
        let d = ref [] in
        (
        match pop stack l with
            Integer n -> let n1 = ref n in
                while !n1 > 0 do
                    let v = pop stack l in
                    d := v :: !d;
                    n1 := !n1 - 1;
                done
          | _ -> raise_exception stack "The number of elements in a new list must be an integer." l
        );
        push (Lst d) stack
  | Head_list l -> 
        (
        match pop stack l with
            Lst vs -> push (List.hd !vs) stack;
          | _ -> raise_exception stack "head_list needs a list to operate on!" l
        )
  | Tail_list l -> 
        (
        match pop stack l with
            Lst vs -> push (Lst (ref (List.tl !vs))) stack;
          | _ -> raise_exception stack "head_list needs a list to operate on!" l
        )
  | Get_list l ->
        let n = pop stack l in
        (
        match (n, pop stack l) with
            (Integer nn, Lst vs) -> push (List.nth !vs nn) stack
          | _ -> raise_exception stack "get_list needs an integer and a list to operate on!" l
        )
  | Set_list l ->
        let n = pop stack l in
        let v = pop stack l in
        (
        match (n, pop stack l) with
            (Integer nn, Lst vs) -> let i = ref (-1) in 
                push (Lst (ref (List.map (
                    fun x -> 
                        i := !i + 1; 
                        if !i=nn then v else x
                    ) !vs))) stack
          | _ -> raise_exception stack "get_list needs an integer and a list to operate on!" l
        )
  | Dup l -> let v = pop stack l in
        push v stack;
        push v stack
  | Discard l ->
        ignore (pop stack l)
  | Typeof l ->
        let v = pop stack l in
        (
        match v with
            Procedure _ -> push (String "procedure") stack
          | Dict _ -> push (String "dict") stack
          | _ -> push (String "not implemented") stack
        )
  | Stacksize l -> push (Integer (Stack.length !stack)) stack
  | Freeze l -> ignore (raise (APostFreeze Noneval))
  
(** Execute a conditional test *)
and exec_cond stack proc l = match proc with
    Procedure (cs, env') -> List.iter (do_cmd stack env') cs;
        (
        match pop stack l with 
            Boolean p -> p;
          | _ -> false                   (* Should throw an exception *)
        )
  | _ -> false                       (* This should also throw an exception *)

(** Execute a procedure, dealing with yield statements as necessary,
    This is works by catching APostYield exceptions and creating FP objects as necessary
    When an APostYield exception is encountered, the current procedure state is stored in an FP object,
    ready to be resumed.
*)
and exec_proc stack proc l = match proc with
    | Procedure (cs, env) -> 
        (
        let next_command = ref 0 in
        let env' = new_env env in
        try (
            List.iter (fun c -> do_cmd stack env' c; next_command := !next_command + 1) cs
            )
        with APostFreeze v -> (
            let fp = FrozenProcedure (cs, env, env', !next_command)  in
            ignore(raise (APostFreeze  fp))
        ))

let _ =
    let filename = ref "-" in
    Arg.parse [] (fun f -> filename := f) "Usage: apost [sourcefile]\nIf no sourcefile is given, code is read from stdin.";
    let code_channel = ref stdin in
    if !filename <> "-" then code_channel := open_in !filename;
    let lexbuf = Lexing.from_channel !code_channel in
    let stack = ref (Stack.create ()) in
    let globals = empty_env () in
    try
        while true do
            let sym = Parser.command Lexer.token lexbuf in
            try
                do_cmd stack globals sym
            with APostException ls ->
                (
                match pop stack !(Lexer.line_number) with
                    String s -> 
                        print_endline ("Fatal Exception at line " ^ (string_of_int (List.hd (List.rev ls))) ^ ": " ^ s);
                        List.iter (fun x -> print_endline (string_of_int x)) (List.rev ls);
                        exit 1;
                  | _ -> 
                        print_endline ("Unknown Fatal Exception at line " ^ (string_of_int (List.hd (List.rev ls))));
                        print_stack stack;
                        exit 1;
                )
              
        done
    with 
        Lexer.Eof -> 
          exit 0
      | Failure s ->
          print_endline ("Unexpected command at line " ^ (string_of_int !(Lexer.line_number))) 


